
Attribute VB_Name = "MStr"
'http://ms.by.ru/HTML/37.htm
'Нечёткое сравнение строк
'Win-кодировка

Public Type RetCount
lngSubRows As Long
lngCountLike As Long
End Type

Public Function IndistinctMatching(lngMaxLen As Long, strStringMatching As String, strStringStandart As String, lngCase As Long) As Long
Dim gret As RetCount
Dim tret As RetCount
Dim lngCurLen As Long

If lngMaxLen = 0 Or Len(strStringMatching) = 0 Or Len(strStringStandart) = 0 Then
    IndistinctMatching = 0
    Exit Function
End If
gret.lngCountLike = 0
gret.lngSubRows = 0
For lngCurLen = 1 To lngMaxLen
    tret = MatchingStrings(strStringMatching, strStringStandart, lngCurLen, lngCase)
    gret.lngCountLike = gret.lngCountLike + tret.lngCountLike
    gret.lngSubRows = gret.lngSubRows + tret.lngSubRows
    tret = MatchingStrings(strStringStandart, strStringMatching, lngCurLen, lngCase)
    gret.lngCountLike = gret.lngCountLike + tret.lngCountLike
    gret.lngSubRows = gret.lngSubRows + tret.lngSubRows
Next lngCurLen
If gret.lngSubRows = 0 Then
    IndistinctMatching = 0
    Exit Function
End If
IndistinctMatching = (gret.lngCountLike / gret.lngSubRows) * 100
End Function

Public Function MatchingStrings(strA As String, strB As String, lngLen As Long, lngCase As Long) As RetCount
Dim tret As RetCount
Dim y As Long, z As Long
Dim strta As String
Dim strtb As String

For z = 1 To Len(strA) - lngLen + 1
    strta = Mid(strA, z, lngLen)
    y = 1
    For y = 1 To Len(strB) - lngLen + 1
        strtb = Mid(strB, y, lngLen)
        If StrComp(strta, strtb, lngCase) = 0 Then
            tret.lngCountLike = tret.lngCountLike + 1
            Exit For
        End If
    Next y
    tret.lngSubRows = tret.lngSubRows + 1
Next z
MatchingStrings.lngCountLike = tret.lngCountLike
MatchingStrings.lngSubRows = tret.lngSubRows
End Function

